unit SaveMHT;

interface
uses
  CDO_TLB, ADODB_TLB, Classes, SysUtils, ActiveX;

procedure SaveToMHT(const URL, DestFileName: string);

// This should be used when you have already set the threading model to multithreaded
procedure SaveToMHT_InCOThread(const URL, DestFileName: string);

implementation

procedure SaveToMHT(const URL, DestFileName: string);
var
  Msg: IMessage;
  Conf: IConfiguration;
  Stream : _Stream;
begin
  Msg := CoMessage.Create;
  Conf := CoConfiguration.Create;
  Msg.Configuration := Conf;
  Msg.CreateMHTMLBody(URL, cdoSuppressNone, '', '');
  Stream := Msg.GetStream;
  Stream.SaveToFile(DestFileName, adSaveCreateOverWrite);
end;

type
  TCOMInitNullThread = class(TThread)
  protected
    FPage, FFile: string;
    Ex: Exception;
    procedure Execute; override;
  end;

procedure SaveToMHT_InCOThread(const URL, DestFileName: string);
begin
  with TCOMInitNullThread.Create(True) do
  try
    FPage:= URL;
    FFile:= DestFileName;
    Resume;
    WaitFor;
    if Ex <> nil then
      raise Ex;
  finally
    Free;
  end;
end;

{ TCOMInitNullThread }

procedure TCOMInitNullThread.Execute;
begin
  CoInitialize(nil);
  try
    SaveToMHT(FPage, FFile);
  except
    on E:Exception do
    begin
      Ex:= E.ClassType.Create as Exception;
      Ex.Message:= E.Message;
    end;
  end;
  CoUninitialize;
end;

end.

